Collection of Tools & Utilities/Collection of Tools and Utilities.iso/c/cug236.zip/PROGS.BC

Text File | 1980-01-02 | 6KB | 335 lines

/* EXAMPLE OF I/O STATEMENTS */
GLOBAL
MAIN
CHAR *S = "STRING", *FLNAME = "TDAT.G"
INTEGER A = 234, B = 678
OPEN #1, "DATA.TST", "w"
PRINT #1, "%s %d %d", S, A, B
CLOSE #1
OPEN #1, "DATA.TST", "r"
INPUT #1, "%s %d %d", *S, A, B
CLOSE #1
PRINT "%s %d %d \n", S, A, B
LIST(FLNAME)
END IOEX

FUNCTION LIST(FILENAME)
CHAR *FILENAME
BEGIN
CHAR C
OPEN #4, FILENAME, "r"
WHILE (C = getc(fp4)) <> EOF
  putchar(C);
ENDWH
CLOSE#4
END LIST

/* ERATOSTHENES SIEVE */
GLOBAL
CON SIZE 8190
MAIN
INTEGER ITER, COUNT, I, K
INTEGER PRIME, FLAG[8191]
PRINT "10 ITERATIONS \n"
FOR ITER = 1 TO 10
  COUNT = 0
  FOR I = 0 TO SIZE
    FLAG[I] = 1
  NEXT I
  FOR I = 0 TO SIZE
    IF FLAG[I] <> 0
      PRIME = I+I+3
      K = I + PRIME
      WHILE K <= SIZE
        FLAG[K] = 0
        K = K + PRIME
      ENDWH
      COUNT++
    ENDIF
  NEXT I
NEXT ITER
PRINT " %d PRIMES \n", COUNT
END SIEVE

/* EIGHT QUEENS CHESS PROBLEM */
GLOBAL
INTEGER COLFREE[8], X[8]
INTEGER UPFREE[15], DOWNFREE[15]
INTEGER R, K
MAIN
/* INITIALIZE EMPTY BOARD */
FOR K=0 TO 7
  COLFREE[K] = TRUE
NEXT K
FOR K=0 TO 14
  UPFREE[K] = DOWNFREE[K] = TRUE
NEXT K
R = -1
ADDQUEEN()
END QUEEN8

FUNCTION ADDQUEEN()
BEGIN
INTEGER C
R++
FOR C=0 TO 7
  /* IS SQUARE[R,C] FREE? */
  IF COLFREE[C] AND UPFREE[R-C+7] AND DOWNFREE[R+C]
    /* SET QUEEN ON SQUARE[R,C] */
    X[R] = C
    COLFREE[C] = UPFREE[R-C+7] = DOWNFREE[R+C] = FALSE
    IF R == 7
      PRINT "\n CONFIGURATION \n"
      FOR K=0 TO 7
        PRINT " %d", X[K]
      NEXT K
      STOP
    ELSE ADDQUEEN()
    ENDIF
    /* REMOVE QUEEN FROM SQUARE[R,C)] */
    COLFREE[C] = UPFREE[R-C+7] = DOWNFREE[R+C] = TRUE
  ENDIF
NEXT C
R--
END ADDQUEEN

/* PRODUCT OF TWO MATRICES OF VARIABLE DIMENSIONS */
GLOBAL
CON DLIM 21
MAIN
REAL A[DLIM,DLIM], B[DLIM,DLIM], C[DLIM,DLIM]
INTEGER I,J,K, N1,N2,N3
PRINT "DIMENSIONS = "
INPUT "%d %d %d", N1, N2, N3
/* GENERATE MATRICES */
FOR J=1 TO N2
  FOR I=1 TO N1
    A[I,J] = (REAL)(J-I)
  NEXT I
  FOR K=1 TO N3
    B[J,K] = (REAL)(J+K)
  NEXT K
NEXT J
MATPRI(A,N1,N2)
MATPRI(B,N2,N3)
MULT(A,B,C,N1,N2,N3)
MATPRI(C,N1,N3)
END MAIN

FUNCTION MULT(E,F,G, L1,L2,L3)
REAL E[DLIM,DLIM], F[DLIM,DLIM], G[DLIM,DLIM]
INTEGER L1, L2, L3
BEGIN
INTEGER I,J,K
FOR I=1 TO L1
  FOR K=1 TO L3
    G[I,K] = 0
    FOR J=1 TO L2
      G[I,K] = G[I,K]+E[I,J]*F[J,K]
    NEXT J
  NEXT K
NEXT I
END MULT

FUNCTION MATPRI(A, L1,L2)
REAL A[DLIM,DLIM]; INTEGER L1, L2
BEGIN
INTEGER I,J
PRINT "\n"
FOR I=1 TO L1
  FOR J=1 TO L2
    PRINT "%8.3f", A[I,J]
  NEXT J
  PRINT "\n"
NEXT I
END MATPRI

/* EXAMPLE USING CONDITIONAL STATEMENTS */
GLOBAL
MAIN
CHAR  *S = "@$^&*+"
INTEGER I
FOR I=1 TO 5
  IF S[I] == '@'
    PRINT "@"
  ELSE IF S[I] == '+'
    PRINT "$"
  ELSE IF S[I] == '^'
    PRINT "^"
  ELSE
    PRINT "NO MATCH"
  ENDIF
NEXT I
END CONDIT

/* TOWERS OF HANOI */
GLOBAL
CON NDISK 64
MAIN
MOVE(NDISK, 1, 3, 2)
END HANOI

FUNCTION MOVE(N, A, B, C)
INTEGER N, A, B, C
BEGIN
IF N > 0
  MOVE(N-1, A, C, B)
  PRINT "MOVE A DISK FROM %d TO %d \n", A, B
  MOVE(N-1, C, B, A)
ENDIF
END MOVE

/* INVERSE AND DETERMINANT OF SYMMETRIC MATRIX */
GLOBAL
CON DLIM 31
MAIN
REAL A[DLIM,DLIM],R[DLIM,DLIM],DET,SINV()
INTEGER I,J,ND
PRINT "ND = "
INPUT "%d", ND
/* GENERATE ND X ND MATRIX */
FOR I=1 TO ND
  FOR J=1 TO ND
    A[I,J]=1.
  NEXT J
  A[I,I]=2.
NEXT I
MATPRI(A,ND,ND)
DET=SINV(A,R,ND)
MATPRI(R,ND,ND)
PRINT "%10.3f\n", DET
ENDMAIN

REAL FUNCTION SINV(A,R,NN)
REAL A[DLIM,DLIM], R[DLIM,DLIM]
INTEGER NN
BEGIN
REAL VEC[DLIM],DET,RL
INTEGER I,J,K,L
DET=A[1,1]
R[1,1]=1./A[1,1]
FOR L=2 TO NN
  K=L-1
  RL=A[L,L]
  FOR I=1 TO K
    VEC[I]=0.
    FOR J=1 TO K
      VEC[I]=VEC[I]+R[I,J]*A[L,J]
    NEXT J
    RL=RL-A[L,I]*VEC[I]
  NEXT I
  DET=DET*RL
  FOR I=1 TO K
    R[L,I]=-VEC[I]/RL
    R[I,L]=R[L,I]
  NEXT I
  FOR I=1 TO K
    FOR J=I TO K
      R[I,J]=R[I,J]-VEC[I]*R[L,J]
      R[J,I]=R[I,J]
    NEXT J
  NEXT I
  R[L,L]=1./RL
NEXT L
RETURN(DET)
END SINV

/* SHELL-METZNER SORT */
GLOBAL
CON DLIM 101
CON NN 20
MAIN
INTEGER X[DLIM]
/* GENERATE VECTOR */
FOR I=1 TO N
  X[I] = N-I+1
NEXT I
PRVEC(X,L)
SZSORT(X,L)
PRVEC(X,L)
END SORT

FUNCTION SZSORT(X,N)
INTEGER X,N
BEGIN
INTEGER KT,TP,I,J, K = 1
WHILE K < N
  K = 2*K
ENDWH
K = K/2 - 1
WHILE K >= 1
  KT=1
  WHILE KT > 0
    J = K
    KT = 0
    FOR I=1 TO N
      J++
      IF J <= N AND X[I] > X[J]
        TP=X[I];X[I]=X[J];X[J]=TP
        KT++
      ENDIF
    NEXT I
  ENDWH
  K = K/2
ENDWH
END SZSORT

FUNCTION PRVEC(A,LL)
INTEGER A[], LL
BEGIN
INTEGER I
PRINT "\n"
FOR I=1 TO LL
  PRINT " %d ", A[I]
NEXT I
PRINT "\n"
RETURN
END PRVEC

/* FIBONACCI NUMBERS */
GLOBAL
MAIN
INTEGER  N
PRINT "N = "
INPUT "%d", N
PRINT "FIBON = %d\n", FIB(N)
END FIBNUM

INTEGER FUNCTION FIB(K)
INTEGER K
BEGIN
IF K <= 2
  RETURN(1)
ELSE
  RETURN(FIB(K-1) + FIB(K-2))
ENDIF
END FIB

/* ZERO OF FUNCTION BY NEWTON'S METHOD */
GLOBAL
MAIN
INTEGER NMAX=20
REAL TOL=1.0E-6, X0, X, NEWT()
X0 = 2
X = NEWT(X0,TOL,NMAX)
PRINT "%f \n", X
END NEWTON

REAL FUNCTION NEWT(X0,TOL,NMAX)
REAL X0,TOL; INTEGER NMAX
BEGIN
REAL FN(), DFN(), fabs(), X, INC
INTEGER I, N
X = X0
FOR I = 1 TO NMAX
  INC = -FN(X)/DFN(X)
  X = X + INC
  IF fabs(INC) < TOL
    RETURN(X)
  ENDIF
NEXT I
PRINT "NO CONVERGENCE"
STOP
END NEWT

^ w